Shareware Grab Bag/Shareware Grab Bag.iso/050/basecalc.arc/BASECALC.PAS

Pascal/Delphi Source File | 1986-03-19 | 16.6 KB | 527 lines

  { name:            Charles Jackson, SJ
    date:            11 January 1986
    computer:        IBM-PC (256K) / PC-DOS ver 2.1
    Pascal compiler: Turbo Pascal (ver 3.0)
    file name:       BASECALC.PAS }

program Base_Calculator(input,output);

  const
    stack_register_size = 60;
  type
    stack_register_type = string[stack_register_size];
    digit_type = array[0..15] of char;
  const
    clear_register =
      '00000000 00000000       00000          0000               ..';
    register_line = 11;
    register_column = 8;
    menu_line = 17;
    quit_command = 'Q';
    digit : digit_type = ('0','1','2','3','4','5','6','7','8','9',
                          'A','B','C','D','E','F');
    base_2_size = 16;
    base_10_size = 5;
    base_16_size = 4;
    ascii_size = 2;
    base_2_end = 17;
    base_10_end = 29;
    base_16_end = 43;
    ascii_end = 60;
    negative_position = 24;
  type
    str_80 = string[80];
    str_20 = string[20];
    stack_type = array[0..3] of stack_register_type;
    real_value_stack_type = array[0..3] of real;
    valid_command_set = set of char;
  var
    stack : stack_type;
    real_value_stack : real_value_stack_type;
    base : byte;
    command : char;

  procedure Print(s : str_80; x, y : byte);
    begin
      GotoXY(x,y);
      write(s);
    end; {Print}

  procedure Print_Rectangle;
    var
      line : byte;
    begin
      ClrScr;
      LowVideo;
      Print('┌──────────────────────────────────────────────────────────'
        + '────────┬──────────┐',1,5);
      Print('│                        Base Calculator                   '
        + '        │ Base:    │',1,6);
      Print('├──────────────────────────────────────────────────────────'
        + '────────┴──────────┤',1,7);
      Print('│',1,8);
      Print('│',79,8);
      Print('│           Binary            Decimal     Hexadecimal      '
        + '    ASCII          │',1,9);
      for line := 10 to 15 do
        begin
          Print('│',1,line);
          Print('│',79,line);
        end;
      Print('├──────────────────────────────────────────────────────────'
        + '───────────────────┤',1,16);
      Print('│',1,17);
      Print('│',79,17);
      Print('└──────────────────────────────────────────────────────────'
        + '───────────────────┘',1,18);
    end; {Print_Rectangle}

  procedure Print_Register(register : byte);
    begin
      HighVideo;
      GotoXY(register_column,register_line + register);
      write(stack[register]);
    end; {Print_Register}

  procedure Initialize;
    var
      register : byte;
    begin
      base := 10;
      HighVideo;
      GotoXY(76,6);
      write(base,' ');
      for register := 0 to 3 do
        begin
          stack[register] := clear_register;
          real_value_stack[register] := 0;
          Print_Register(register);
        end;
    end; {Initialize}

  procedure Push(stack_register : stack_register_type; value : real);
    var
      register : byte;
    begin
      for register := 3 downto 0 do
        begin
          if register > 0
            then stack[register] := stack[register-1]
            else stack[register] := stack_register;
          if register > 0
            then real_value_stack[register] := real_value_stack[register-1]
            else real_value_stack[register] := value;
          Print_Register(register);
        end;
    end; {Push}

  procedure Pop;
    var
      register : byte;
    begin
      for register := 0 to 3 do
        begin
          if register < 3
            then stack[register] := stack[register+1]
            else stack[register] := clear_register;
          if register < 3
            then real_value_stack[register] := real_value_stack[register+1]
            else real_value_stack[register] := 0;
        end;
    end; {Pop}

  procedure Get_Valid_Command(var command : char;
                              column : byte;
                              valid_commands : valid_command_set);
    begin
      repeat
        GotoXY(column,menu_line);
        read(kbd,command);
      until command in valid_commands;
      if command > 'Z'
        then command := chr(ord(command) - 32);
    end; {Get_Valid_Command}

  procedure Clear_Command_Line;
    begin
      GotoXY(2,menu_line);
      write(' ':77);
    end; {Clear_Command_Line}

  procedure Get_Value_String(var input_string : str_20;
                             var value_size : byte;
                             base : byte;
                             var quit : boolean);
    const
      backspace = #8;
      return = #13;
      space = #32;
    var
      ch : char;
      index, max_value_size : byte;
      valid_digits : set of char;
    begin
      case base of
        2  : begin
               max_value_size := base_2_size;
               valid_digits := ['0','1'];
             end;
        10 : begin
               max_value_size := base_10_size;
               valid_digits := ['0'..'9'];
             end;
        16 : begin
               max_value_size := base_16_size;
               valid_digits := ['0'..'9','A'..'F','a'..'f'];
             end;
      end;
      value_size := 0;
      input_string := '00000000000000000000';
      repeat
        read(kbd,ch);
        if (ch in valid_digits) and (value_size < max_value_size) then
          begin
            value_size := value_size + 1;
            if ch in ['a'..'z']
              then ch := chr(ord(ch) - 32);
            input_string[value_size] := ch;
            write(ch);
          end;
        if (ch = backspace) and (value_size > 0) then
          begin
            write(backspace,space,backspace);
            value_size := value_size - 1;
          end;
        quit := (ch = 'q') or (ch = 'Q');
      until (ch = return) or quit;
    end; {Get_Value_String}

  procedure Store_Value_String(var register : stack_register_type;
                               input_string : str_20;
                               value_size, base : byte);
    var
      register_index, input_index : byte;
    begin
      case base of
        2  : register_index := base_2_end;
        10 : register_index := base_10_end;
        16 : register_index := base_16_end;
      end;
      for input_index := value_size downto 1 do
        begin
          if register_index = 9
            then register_index := register_index - 1;
          register[register_index] := input_string[input_index];
          register_index := register_index - 1;
        end;
    end; {Store_Value_String}

  function digit_value(d : char) : integer;
    begin
      case d of
        '0'..'9' : digit_value := ord(d) - ord('0');
        'A'..'F' : digit_value := ord(d) - 55;
      end;
    end; {digit_value}

  procedure Get_Real_Value(var real_value: real;
                           input_string : str_20;
                           value_size, base : byte);
    var
      index : byte;
      multiplier : real;
    begin
      real_value := 0;
      multiplier := 1;
      for index := value_size downto 1 do
        begin
          real_value := real_value
                        + (digit_value(input_string[index]) * multiplier);
          multiplier := multiplier * base;
        end;
    end; {Get_Real_Value}

  procedure Convert_Base_10(var register : stack_register_type;
                            real_value : real);
    var
      index : byte;
      convert_string : str_20;
    begin
      Str(real_value:20:0,convert_string);
      index := 20;
      while convert_string[index] <> ' ' do
        begin
          if convert_string[index] = '-'
            then register[negative_position] := '-'
            else register[index+9] := convert_string[index];
          index := index - 1;
        end;
    end; {Convert_Base_10}

  function remainder(real_value : real; convert_base : integer) : char;
    var
      integer_remainder : byte;
    begin
      integer_remainder := trunc(real_value - (int(real_value/convert_base)
                                              * convert_base));
      remainder := digit[integer_remainder];
    end; {remainder}

  procedure Convert_Value_String(var register : stack_register_type;
                                 real_value : real;
                                 convert_base, end_position, quit : byte);
    var
      index : byte;
    begin
      index := end_position;
      while (real_value <> 0) and (index > quit) do
        begin
          register[index] := remainder(real_value,convert_base);
          index := index - 1;
          if index = 9
            then index := index - 1;
          real_value := int(real_value / convert_base);
        end;
    end; {Convert_Value_String}

  procedure Convert_ASCII(var register : stack_register_type; real_value : real);
    var
      left, right : byte;
    begin
      right := trunc(real_value - int(real_value/256) * 256);
      left := trunc(real_value / 256);
      if right >= 32
        then register[ascii_end] := chr(right);
      if left >= 32
        then register[ascii_end-1] := chr(left);
    end; {Convert_ASCII}

  procedure Store_Value(input_string : str_20; value_size, base : byte);
    var
      real_value : real;
      register : stack_register_type;
    begin
      register := clear_register;
      Store_Value_String(register,input_string,value_size,base);
      Get_Real_Value(real_value,input_string,value_size,base);
      case base of
        2  : begin
               Convert_Base_10(register,real_value);
               Convert_Value_String(register,real_value,16,base_16_end,40);
             end;
        10 : begin
               Convert_Value_String(register,real_value,2,base_2_end,1);
               Convert_Value_String(register,real_value,16,base_16_end,40);
             end;
        16 : begin
               Convert_Value_String(register,real_value,2,base_2_end,1);
               Convert_Base_10(register,real_value);
             end;
      end;
      Convert_ASCII(register,real_value);
      Push(register,real_value);
    end; {Store_Value}

  procedure Enter_Value_Main;
    var
      input_string : str_20;
      value_size : byte;
      quit : boolean;
    begin
      repeat
        HighVideo;
        Clear_Command_Line;
        LowVideo;
        GotoXY(17,menu_line);
        write('Enter base ',base,' value:');
        Print('( )uit.',56,menu_line);
        HighVideo;
        Print('Q',57,menu_line);
        GotoXY(38,menu_line);
        Get_Value_String(input_string,value_size,base,quit);
        if not quit then
          Store_Value(input_string,value_size,base);
      until quit;
    end; {Enter_Value_Main}

  procedure Print_Operation_Menu(var command : char);
    begin
      LowVideo;
      Clear_Command_Line;
      Print('( )ND  ( )R  ( )OR  ( )EG',11,menu_line);
      Print('.  ( )uit.',48,menu_line);
      HighVideo;
      Print('A',12,menu_line);
      Print('O',19,menu_line);
      Print('X',25,menu_line);
      Print('N',32,menu_line);
      Print('Q',52,menu_line);
      Print('+  -  *  /',38,menu_line);
      Print('Command:',60,menu_line);
      Get_Valid_Command(command,69,
        ['A','a','O','o','X','x','N','n','Q','q','+','-','*','/']);
    end; {Print_Operation_Menu}

  procedure Do_Logic_Operation(operation : char);
    var
      register : stack_register_type;
      value_string : str_20;
      index, value_string_index : byte;
      real_value : real;
      test : boolean;
    begin
      value_string := '00000000000000000000';
      register := clear_register;
      index := base_2_end;
      value_string_index := 16;
      repeat
        case operation of
          'A' : test := (stack[0][index] = '1') and (stack[1][index] = '1');
          'O' : test := (stack[0][index] = '1') or (stack[1][index] = '1');
          'X' : test := stack[0][index] <> stack[1][index];
        end;
        if test
          then value_string[value_string_index] := '1'
          else value_string[value_string_index] := '0';
        if value_string[value_string_index] = '1'
          then register[index] := '1';
        value_string_index := value_string_index - 1;
        if index = 9
          then index := index - 2
          else index := index - 1;
      until index = 0;
      Get_Real_Value(real_value,value_string,base_2_size,2);
      Convert_Base_10(register,real_value);
      Convert_Value_String(register,real_value,16,base_16_end,40);
      Convert_ASCII(register,real_value);
      Pop;
      Pop;
      Push(register,real_value);
    end; {Do_Logic_Operation}

  procedure Store_Negative(real_value : real);
    var
      register : stack_register_type;
      twos_complement : real;
    begin
      register := clear_register;
      Convert_Base_10(register,real_value);
      twos_complement := 65536.0 + real_value;
      Convert_Value_String(register,twos_complement,2,base_2_end,1);
      Convert_Value_String(register,twos_complement,16,base_16_end,40);
      Convert_ASCII(register,twos_complement);
      Pop;
      Push(register,real_value);
    end; {Store_Negative}

  procedure Do_Arithmetic_Operation(operation : char);
    var
      register : stack_register_type;
      real_value : real;
    begin
      case operation of
        'A' : real_value := real_value_stack[0] + real_value_stack[1];
        'S' : real_value := real_value_stack[1] - real_value_stack[0];
        'M' : real_value := real_value_stack[0] * real_value_stack[1];
        'D' : if real_value_stack[0] <> 0
                then real_value :=
                  int(real_value_stack[1] / real_value_stack[0])
                else real_value := 0;
      end;
      if real_value < 0
        then
          begin
            Pop;
            Store_Negative(real_value)
          end
        else
          begin
            register := clear_register;
            Convert_Value_String(register,real_value,2,base_2_end,1);
            Convert_Base_10(register,real_value);
            Convert_Value_String(register,real_value,16,base_16_end,40);
            Convert_ASCII(register,real_value);
            Pop;
            Pop;
            Push(register,real_value);
          end;
    end; {Do_Arithmetic_Operation}

  procedure Enter_Operation_Main;
    var
      command : char;
    begin
      repeat
        Print_Operation_Menu(command);
        if command <> quit_command then
          case command of
            'A' : Do_Logic_Operation('A');
            'O' : Do_Logic_Operation('O');
            'X' : Do_Logic_Operation('X');
            'N' : Store_Negative(-real_value_stack[0]);
            '+' : Do_Arithmetic_Operation('A');
            '-' : Do_Arithmetic_Operation('S');
            '*' : Do_Arithmetic_Operation('M');
            '/' : Do_Arithmetic_Operation('D');
          end;
      until command = quit_command;
    end; {Enter_Operation_Main}

  procedure Set_Base_Main;
    var
      input_string : str_20;
      real_value : real;
      value_size : byte;
      quit : boolean;
    begin
      repeat
        HighVideo;
        Clear_Command_Line;
        LowVideo;
        Print('Enter base: <2,10,16>:',22,menu_line);
        Print('( )uit.',51,menu_line);
        HighVideo;
        Print('Q',52,menu_line);
        GotoXY(45,menu_line);
        Get_Value_String(input_string,value_size,10,quit);
        if not quit then
          begin
            Get_Real_Value(real_value,input_string,value_size,10);
            base := trunc(real_value);
            if base in [2,10,16] then
              begin
                GotoXY(76,6);
                write(base,' ');
              end;
          end;
      until (base in [2,10,16]) or quit;
    end; {Set_Base_Main}

  procedure Print_Main_Menu(var command : char);
    begin
      Clear_Command_Line;
      LowVideo;
      Print('Enter ( )alue/( )peration/( )ase.  ( )uit.',14,menu_line);
      HighVideo;
      Print('V',21,menu_line);
      Print('O',29,menu_line);
      Print('B',41,menu_line);
      Print('Q',50,menu_line);
      Print('Command:',58,menu_line);
      Get_Valid_Command(command,67,['V','v','O','o','B','b','Q','q']);
    end; {Print_Main_Menu}

  begin
    Print_Rectangle;
    Initialize;
    repeat
      Print_Main_Menu(command);
      if command <> quit_command then
        case command of
          'V' : Enter_Value_Main;
          'O' : Enter_Operation_Main;
          'B' : Set_Base_Main;
        end;
    until command = quit_command;
    GotoXY(1,23);
  end. {Base_Calculator}